home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / chars.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-16  |  8.2 KB  |  372 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include <ctype.h>
  45. #include "_scm.h"
  46.  
  47.  
  48.  
  49.  
  50. PROC1 (s_char_p, "char?", tc7_rpsubr, scm_char_p);
  51. #ifdef __STDC__
  52. SCM
  53. scm_char_p(SCM x)
  54. #else
  55. SCM
  56. scm_char_p(x)
  57.      SCM x;
  58. #endif
  59. {
  60.   return ICHRP(x) ? BOOL_T : BOOL_F;
  61. }
  62.  
  63. PROC1 (s_char_eq_p, "char=?", tc7_rpsubr, scm_char_eq_p);
  64. #ifdef __STDC__
  65. SCM
  66. scm_char_eq_p(SCM x, SCM y)
  67. #else
  68. SCM
  69. scm_char_eq_p(x, y)
  70.      SCM x;
  71.      SCM y;
  72. #endif
  73. {
  74.   ASSERT(ICHRP(x), x, ARG1, s_char_eq_p);
  75.   ASSERT(ICHRP(y), y, ARG2, s_char_eq_p);
  76.   return (ICHR(x) == ICHR(y)) ? BOOL_T : BOOL_F;
  77. }
  78.  
  79.  
  80. PROC1 (s_char_less_p, "char<?", tc7_rpsubr, scm_char_less_p);
  81. #ifdef __STDC__
  82. SCM
  83. scm_char_less_p(SCM x, SCM y)
  84. #else
  85. SCM
  86. scm_char_less_p(x, y)
  87.      SCM x;
  88.      SCM y;
  89. #endif
  90. {
  91.   ASSERT(ICHRP(x), x, ARG1, s_char_less_p);
  92.   ASSERT(ICHRP(y), y, ARG2, s_char_less_p);
  93.   return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F;
  94. }
  95.  
  96. PROC1 (s_char_leq_p, "char<=?", tc7_rpsubr, scm_char_leq_p);
  97. #ifdef __STDC__
  98. SCM
  99. scm_char_leq_p(SCM x, SCM y)
  100. #else
  101. SCM
  102. scm_char_leq_p(x, y)
  103.      SCM x;
  104.      SCM y;
  105. #endif
  106. {
  107.   ASSERT(ICHRP(x), x, ARG1, s_char_leq_p);
  108.   ASSERT(ICHRP(y), y, ARG2, s_char_leq_p);
  109.   return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F;
  110. }
  111.  
  112. PROC1 (s_char_gr_p, "char>?", tc7_rpsubr, scm_char_gr_p);
  113. #ifdef __STDC__
  114. SCM
  115. scm_char_gr_p(SCM x, SCM y)
  116. #else
  117. SCM
  118. scm_char_gr_p(x, y)
  119.      SCM x;
  120.      SCM y;
  121. #endif
  122. {
  123.   ASSERT(ICHRP(x), x, ARG1, s_char_gr_p);
  124.   ASSERT(ICHRP(y), y, ARG2, s_char_gr_p);
  125.   return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F;
  126. }
  127.  
  128. PROC1 (s_char_geq_p, "char>=?", tc7_rpsubr, scm_char_geq_p);
  129. #ifdef __STDC__
  130. SCM
  131. scm_char_geq_p(SCM x, SCM y)
  132. #else
  133. SCM
  134. scm_char_geq_p(x, y)
  135.      SCM x;
  136.      SCM y;
  137. #endif
  138. {
  139.   ASSERT(ICHRP(x), x, ARG1, s_char_geq_p);
  140.   ASSERT(ICHRP(y), y, ARG2, s_char_geq_p);
  141.   return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F;
  142. }
  143.  
  144. PROC1 (s_char_ci_eq_p, "char-ci=?", tc7_rpsubr, scm_char_ci_eq_p);
  145. #ifdef __STDC__
  146. SCM
  147. scm_char_ci_eq_p(SCM x, SCM y)
  148. #else
  149. SCM
  150. scm_char_ci_eq_p(x, y)
  151.      SCM x;
  152.      SCM y;
  153. #endif
  154. {
  155.   ASSERT(ICHRP(x), x, ARG1, s_char_ci_eq_p);
  156.   ASSERT(ICHRP(y), y, ARG2, s_char_ci_eq_p);
  157.   return (scm_upcase[ICHR(x)]==scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
  158. }
  159.  
  160. PROC1 (s_char_ci_less_p, "char-ci<?", tc7_rpsubr, scm_char_ci_less_p);
  161. #ifdef __STDC__
  162. SCM
  163. scm_char_ci_less_p(SCM x, SCM y)
  164. #else
  165. SCM
  166. scm_char_ci_less_p(x, y)
  167.      SCM x;
  168.      SCM y;
  169. #endif
  170. {
  171.   ASSERT(ICHRP(x), x, ARG1, s_char_ci_less_p);
  172.   ASSERT(ICHRP(y), y, ARG2, s_char_ci_less_p);
  173.   return (scm_upcase[ICHR(x)] < scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
  174. }
  175.  
  176. PROC1 (s_char_ci_leq_p, "char-ci<=?", tc7_rpsubr, scm_char_ci_leq_p);
  177. #ifdef __STDC__
  178. SCM
  179. scm_char_ci_leq_p(SCM x, SCM y)
  180. #else
  181. SCM
  182. scm_char_ci_leq_p(x, y)
  183.      SCM x;
  184.      SCM y;
  185. #endif
  186. {
  187.   ASSERT(ICHRP(x), x, ARG1, s_char_ci_leq_p);
  188.   ASSERT(ICHRP(y), y, ARG2, s_char_ci_leq_p);
  189.   return (scm_upcase[ICHR(x)] <= scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
  190. }
  191.  
  192. PROC1 (s_char_ci_gr_p, "char-ci>?", tc7_rpsubr, scm_char_ci_gr_p);
  193. #ifdef __STDC__
  194. SCM
  195. scm_char_ci_gr_p(SCM x, SCM y)
  196. #else
  197. SCM
  198. scm_char_ci_gr_p(x, y)
  199.      SCM x;
  200.      SCM y;
  201. #endif
  202. {
  203.   ASSERT(ICHRP(x), x, ARG1, s_char_ci_gr_p);
  204.   ASSERT(ICHRP(y), y, ARG2, s_char_ci_gr_p);
  205.   return (scm_upcase[ICHR(x)] > scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
  206. }
  207.  
  208. PROC1 (s_char_ci_geq_p, "char-ci>=?", tc7_rpsubr, scm_char_ci_geq_p);
  209. #ifdef __STDC__
  210. SCM
  211. scm_char_ci_geq_p(SCM x, SCM y)
  212. #else
  213. SCM
  214. scm_char_ci_geq_p(x, y)
  215.      SCM x;
  216.      SCM y;
  217. #endif
  218. {
  219.   ASSERT(ICHRP(x), x, ARG1, s_char_ci_geq_p);
  220.   ASSERT(ICHRP(y), y, ARG2, s_char_ci_geq_p);
  221.   return (scm_upcase[ICHR(x)] >= scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
  222. }
  223.  
  224.  
  225. PROC (s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);
  226. #ifdef __STDC__
  227. SCM
  228. scm_char_alphabetic_p(SCM chr)
  229. #else
  230. SCM
  231. scm_char_alphabetic_p(chr)
  232.      SCM chr;
  233. #endif
  234. {
  235.   ASSERT(ICHRP(chr), chr, ARG1, s_char_alphabetic_p);
  236.   return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F;
  237. }
  238.  
  239. PROC (s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);
  240. #ifdef __STDC__
  241. SCM
  242. scm_char_numeric_p(SCM chr)
  243. #else
  244. SCM
  245. scm_char_numeric_p(chr)
  246.      SCM chr;
  247. #endif
  248. {
  249.   ASSERT(ICHRP(chr), chr, ARG1, s_char_numeric_p);
  250.   return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F;
  251. }
  252.  
  253. PROC (s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);
  254. #ifdef __STDC__
  255. SCM
  256. scm_char_whitespace_p(SCM chr)
  257. #else
  258. SCM
  259. scm_char_whitespace_p(chr)
  260.      SCM chr;
  261. #endif
  262. {
  263.   ASSERT(ICHRP(chr), chr, ARG1, s_char_whitespace_p);
  264.   return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F;
  265. }
  266.  
  267.  
  268.  
  269. PROC (s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);
  270. #ifdef __STDC__
  271. SCM
  272. scm_char_upper_case_p(SCM chr)
  273. #else
  274. SCM
  275. scm_char_upper_case_p(chr)
  276.      SCM chr;
  277. #endif
  278. {
  279.   ASSERT(ICHRP(chr), chr, ARG1, s_char_upper_case_p);
  280.   return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F;
  281. }
  282.  
  283.  
  284. PROC (s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);
  285. #ifdef __STDC__
  286. SCM
  287. scm_char_lower_case_p(SCM chr)
  288. #else
  289. SCM
  290. scm_char_lower_case_p(chr)
  291.      SCM chr;
  292. #endif
  293. {
  294.   ASSERT(ICHRP(chr), chr, ARG1, s_char_lower_case_p);
  295.   return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F;
  296. }
  297.  
  298.  
  299. PROC (s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);
  300. #ifdef __STDC__
  301. SCM
  302. scm_char_to_integer(SCM chr)
  303. #else
  304. SCM
  305. scm_char_to_integer(chr)
  306.      SCM chr;
  307. #endif
  308. {
  309.   ASSERT(ICHRP(chr), chr, ARG1, s_char_to_integer);
  310.   return MAKINUM(ICHR(chr));
  311. }
  312.  
  313.  
  314.  
  315. PROC (s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);
  316. #ifdef __STDC__
  317. SCM
  318. scm_integer_to_char(SCM n)
  319. #else
  320. SCM
  321. scm_integer_to_char(n)
  322.      SCM n;
  323. #endif
  324. {
  325.   ASSERT(INUMP(n), n, ARG1, s_integer_to_char);
  326.   ASSERT((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
  327.      n, OUTOFRANGE, s_integer_to_char);
  328.   return MAKICHR(INUM(n));
  329. }
  330.  
  331.  
  332. PROC (s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);
  333. #ifdef __STDC__
  334. SCM
  335. scm_char_upcase(SCM chr)
  336. #else
  337. SCM
  338. scm_char_upcase(chr)
  339.      SCM chr;
  340. #endif
  341. {
  342.   ASSERT(ICHRP(chr), chr, ARG1, s_char_upcase);
  343.   return MAKICHR(scm_upcase[ICHR(chr)]);
  344. }
  345.  
  346.  
  347. PROC (s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);
  348. #ifdef __STDC__
  349. SCM
  350. scm_char_downcase(SCM chr)
  351. #else
  352. SCM
  353. scm_char_downcase(chr)
  354.      SCM chr;
  355. #endif
  356. {
  357.   ASSERT(ICHRP(chr), chr, ARG1, s_char_downcase);
  358.   return MAKICHR(scm_downcase[ICHR(chr)]);
  359. }
  360.  
  361. #ifdef __STDC__
  362. void
  363. scm_init_chars (void)
  364. #else
  365. void
  366. scm_init_chars ()
  367. #endif
  368. {
  369. #include "chars.x"
  370. }
  371.  
  372.